home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 176_01 / xlread.c < prev    next >
Text File  |  1985-12-08  |  16KB  |  743 lines
  1. /* xlread - xlisp expression input routine */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *s_stdout,*true,*s_dot;
  14. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  15. extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
  16. extern NODE ***xlstack;
  17. extern int xlplevel;
  18. extern char buf[];
  19.  
  20. /* external routines */
  21. extern FILE *fopen();
  22. extern double atof();
  23. extern ITYPE;
  24.  
  25. #define WSPACE "\t \f\r\n"
  26. #define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
  27. #define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  28.  
  29. /* forward declarations */
  30. FORWARD NODE *callmacro();
  31. FORWARD NODE *phexnumber(),*pquote(),*plist(),*pvector(),*pname();
  32. FORWARD NODE *tentry();
  33.  
  34. /* xlload - load a file of xlisp expressions */
  35. int xlload(fname,vflag,pflag)
  36.   char *fname; int vflag,pflag;
  37. {
  38.     NODE ***oldstk,*fptr,*expr;
  39.     char fullname[STRMAX+1];
  40.     CONTEXT cntxt;
  41.     FILE *fp;
  42.     int sts;
  43.  
  44.     /* create a new stack frame */
  45.     oldstk = xlsave(&fptr,&expr,NULL);
  46.  
  47.     /* create the full file name */
  48.     if (needsextension(fname)) {
  49.     strcpy(fullname,fname);
  50.     strcat(fullname,".lsp");
  51.     fname = fullname;
  52.     }
  53.  
  54.     /* allocate a file node */
  55.     fptr = cvfile(NULL);
  56.  
  57.     /* print the information line */
  58.     if (vflag)
  59.     { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  60.  
  61.     /* open the file */
  62.     if ((fp = fopen(fname,"r")) == NULL) {
  63.     xlstack = oldstk;
  64.     return (FALSE);
  65.     }
  66.     setfile(fptr,fp);
  67.  
  68.     /* read, evaluate and possibly print each expression in the file */
  69.     xlbegin(&cntxt,CF_ERROR,true);
  70.     if (setjmp(cntxt.c_jmpbuf))
  71.     sts = FALSE;
  72.     else {
  73.     while (xlread(fptr,&expr,FALSE)) {
  74.         expr = xleval(expr);
  75.         if (pflag)
  76.         stdprint(expr);
  77.     }
  78.     sts = TRUE;
  79.     }
  80.     xlend(&cntxt);
  81.  
  82.     /* close the file */
  83.     fclose(getfile(fptr));
  84.     setfile(fptr,NULL);
  85.  
  86.     /* restore the previous stack frame */
  87.     xlstack = oldstk;
  88.  
  89.     /* return status */
  90.     return (sts);
  91. }
  92.  
  93. /* xlread - read an xlisp expression */
  94. int xlread(fptr,pval,rflag)
  95.   NODE *fptr,**pval; int rflag;
  96. {
  97.     int sts;
  98.  
  99.     /* reset the paren nesting level */
  100.     if (!rflag)
  101.     xlplevel = 0;
  102.  
  103.     /* read an expression */
  104.     while ((sts = readone(fptr,pval)) == FALSE)
  105.     ;
  106.  
  107.     /* return status */
  108.     return (sts == EOF ? FALSE : TRUE);
  109. }
  110.  
  111. /* readone - attempt to read a single expression */
  112. int readone(fptr,pval)
  113.   NODE *fptr,**pval;
  114. {
  115.     NODE *val,*type;
  116.     int ch;
  117.  
  118.     /* get a character and check for EOF */
  119.     if ((ch = xlgetc(fptr)) == EOF)
  120.     return (EOF);
  121.  
  122.     /* handle white space */
  123.     if ((type = tentry(ch)) == k_wspace)
  124.     return (FALSE);
  125.  
  126.     /* handle symbol constituents */
  127.     else if (type == k_const) {
  128.     *pval = pname(fptr,ch);
  129.     return (TRUE);
  130.     }
  131.  
  132.     /* handle read macros */
  133.     else if (consp(type)) {
  134.     if ((val = callmacro(fptr,ch)) && consp(val)) {
  135.         *pval = car(val);
  136.         return (TRUE);
  137.     }
  138.     else
  139.         return (FALSE);
  140.     }
  141.  
  142.     /* handle illegal characters */
  143.     else
  144.     xlerror("illegal character",cvfixnum((FIXNUM)ch));
  145. }
  146.  
  147. /* rmhash - read macro for '#' */
  148. NODE *rmhash(args)
  149.   NODE *args;
  150. {
  151.     NODE ***oldstk,*fptr,*mch,*val;
  152.     int ch;
  153.  
  154.     /* create a new stack frame */
  155.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  156.  
  157.     /* get the file and macro character */
  158.     fptr = xlgetfile(&args);
  159.     mch = xlmatch(INT,&args);
  160.     xllastarg(args);
  161.  
  162.     /* make the return value */
  163.     val = consa(NIL);
  164.  
  165.     /* check the next character */
  166.     switch (ch = xlgetc(fptr)) {
  167.     case '\'':
  168.         rplaca(val,pquote(fptr,s_function));
  169.         break;
  170.     case '(':
  171.         rplaca(val,pvector(fptr));
  172.         break;
  173.     case 'x':
  174.     case 'X':
  175.             rplaca(val,phexnumber(fptr));
  176.         break;
  177.     case '\\':
  178.         rplaca(val,cvfixnum((FIXNUM)xlgetc(fptr)));
  179.         break;
  180.     default:
  181.         xlerror("illegal character after #",cvfixnum((FIXNUM)ch));
  182.     }
  183.  
  184.     /* restore the previous stack frame */
  185.     xlstack = oldstk;
  186.  
  187.     /* return the value */
  188.     return (val);
  189. }
  190.  
  191. /* rmquote - read macro for '\'' */
  192. NODE *rmquote(args)
  193.   NODE *args;
  194. {
  195.     NODE ***oldstk,*fptr,*mch,*val;
  196.     int ch;
  197.  
  198.     /* create a new stack frame */
  199.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  200.  
  201.     /* get the file and macro character */
  202.     fptr = xlgetfile(&args);
  203.     mch = xlmatch(INT,&args);
  204.     xllastarg(args);
  205.  
  206.     /* make the return value */
  207.     val = consa(NIL);
  208.     rplaca(val,pquote(fptr,s_quote));
  209.  
  210.     /* restore the previous stack frame */
  211.     xlstack = oldstk;
  212.  
  213.     /* return the value */
  214.     return (val);
  215. }
  216.  
  217. /* rmdquote - read macro for '"' */
  218. NODE *rmdquote(args)
  219.   NODE *args;
  220. {
  221.     NODE ***oldstk,*fptr,*mch,*val;
  222.     int ch,i,d1,d2,d3;
  223.  
  224.     /* create a new stack frame */
  225.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  226.  
  227.     /* get the file and macro character */
  228.     fptr = xlgetfile(&args);
  229.     mch = xlmatch(INT,&args);
  230.     xllastarg(args);
  231.  
  232.     /* loop looking for a closing quote */
  233.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  234.     switch (ch) {
  235.     case '\\':
  236.         switch (ch = checkeof(fptr)) {
  237.         case 'f':
  238.             ch = '\f';
  239.             break;
  240.         case 'n':
  241.             ch = '\n';
  242.             break;
  243.         case 'r':
  244.             ch = '\r';
  245.             break;
  246.         case 't':
  247.             ch = '\t';
  248.             break;
  249.         default:
  250.             if (ch >= '0' && ch <= '7') {
  251.                 d1 = ch - '0';
  252.                 d2 = checkeof(fptr) - '0';
  253.                 d3 = checkeof(fptr) - '0';
  254.                 ch = (d1 << 6) + (d2 << 3) + d3;
  255.             }
  256.             break;
  257.         }
  258.     }
  259.     buf[i] = ch;
  260.     }
  261.     buf[i] = 0;
  262.  
  263.     /* initialize the node */
  264.     val = consa(NIL);
  265.     rplaca(val,cvstring(buf));
  266.  
  267.     /* restore the previous stack frame */
  268.     xlstack = oldstk;
  269.  
  270.     /* return the new string */
  271.     return (val);
  272. }
  273.  
  274. /* rmbquote - read macro for '`' */
  275. NODE *rmbquote(args)
  276.   NODE *args;
  277. {
  278.     NODE ***oldstk,*fptr,*mch,*val;
  279.     int ch;
  280.  
  281.     /* create a new stack frame */
  282.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  283.  
  284.     /* get the file and macro character */
  285.     fptr = xlgetfile(&args);
  286.     mch = xlmatch(INT,&args);
  287.     xllastarg(args);
  288.  
  289.     /* make the return value */
  290.     val = consa(NIL);
  291.     rplaca(val,pquote(fptr,s_bquote));
  292.  
  293.     /* restore the previous stack frame */
  294.     xlstack = oldstk;
  295.  
  296.     /* return the value */
  297.     return (val);
  298. }
  299.  
  300. /* rmcomma - read macro for ',' */
  301. NODE *rmcomma(args)
  302.   NODE *args;
  303. {
  304.     NODE ***oldstk,*fptr,*mch,*val,*sym;
  305.     int ch;
  306.  
  307.     /* create a new stack frame */
  308.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  309.  
  310.     /* get the file and macro character */
  311.     fptr = xlgetfile(&args);
  312.     mch = xlmatch(INT,&args);
  313.     xllastarg(args);
  314.  
  315.     /* check the next character */
  316.     if (xlpeek(fptr) == '@') {
  317.     sym = s_comat;
  318.     xlgetc(fptr);
  319.     }
  320.     else
  321.     sym = s_comma;
  322.  
  323.     /* make the return value */
  324.     val = consa(NIL);
  325.     rplaca(val,pquote(fptr,sym));
  326.  
  327.     /* restore the previous stack frame */
  328.     xlstack = oldstk;
  329.  
  330.     /* return the value */
  331.     return (val);
  332. }
  333.  
  334. /* rmlpar - read macro for '(' */
  335. NODE *rmlpar(args)
  336.   NODE *args;
  337. {
  338.     NODE ***oldstk,*fptr,*mch,*val;
  339.     int ch;
  340.  
  341.     /* create a new stack frame */
  342.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  343.  
  344.     /* get the file and macro character */
  345.     fptr = xlgetfile(&args);
  346.     mch = xlmatch(INT,&args);
  347.     xllastarg(args);
  348.  
  349.     /* make the return value */
  350.     val = consa(NIL);
  351.     rplaca(val,plist(fptr));
  352.  
  353.     /* restore the previous stack frame */
  354.     xlstack = oldstk;
  355.  
  356.     /* return the value */
  357.     return (val);
  358. }
  359.  
  360. /* rmrpar - read macro for ')' */
  361. NODE *rmrpar(args)
  362.   NODE *args;
  363. {
  364.     xlfail("misplaced right paren");
  365. }
  366.  
  367. /* rmsemi - read macro for ';' */
  368. NODE *rmsemi(args)
  369.   NODE *args;
  370. {
  371.     NODE ***oldstk,*fptr,*mch;
  372.     int ch;
  373.  
  374.     /* create a new stack frame */
  375.     oldstk = xlsave(&fptr,&mch,NULL);
  376.  
  377.     /* get the file and macro character */
  378.     fptr = xlgetfile(&args);
  379.     mch = xlmatch(INT,&args);
  380.     xllastarg(args);
  381.  
  382.     /* skip to en